home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / class.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  43KB  |  1,648 lines
  1. /* ******************************************************************** */
  2. /*  class.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* classes                                                    */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: class.c,v 1.16 1992/06/12 00:03:02 pab Exp $
  9.  *
  10.  * $Log: class.c,v $
  11.  * Revision 1.16  1992/06/12  00:03:02  pab
  12.  * added more reflective-type hacks
  13.  *
  14.  * Revision 1.15  1992/06/09  13:58:35  pab
  15.  * added set class , etc
  16.  *
  17.  * Revision 1.14  1992/05/26  12:28:40  pab
  18.  * fixed for moving modules (xxx_template)
  19.  *
  20.  * Revision 1.13  1992/05/19  11:15:58  pab
  21.  * exported alloc class, instance
  22.  *
  23.  * Revision 1.12  1992/04/26  21:00:15  pab
  24.  * alloc_int fixes
  25.  *
  26.  * Revision 1.11  1992/03/14  14:33:48  pab
  27.  * side efects return values
  28.  *
  29.  * Revision 1.10  1992/02/27  15:46:57  pab
  30.  * bytecode + error changes
  31.  *
  32.  * Revision 1.9  1992/01/29  13:39:10  pab
  33.  * Fixed gc bug
  34.  *
  35.  * Revision 1.8  1992/01/22  13:29:49  pab
  36.  * Fixed GC bug
  37.  *
  38.  * Revision 1.7  1992/01/17  22:28:06  pab
  39.  * Removed defstruct + defclass 'cos
  40.  * no one used them
  41.  *
  42.  * Revision 1.6  1992/01/09  22:28:46  pab
  43.  * Fixed for low tag ints
  44.  *
  45.  * Revision 1.5  1992/01/05  22:47:57  pab
  46.  * Minor bug fixes, plus BSD version
  47.  *
  48.  * Revision 1.4  1991/12/22  15:13:56  pab
  49.  * Xmas revision
  50.  *
  51.  * Revision 1.3  1991/11/15  13:44:31  pab
  52.  * copyalloc rev 0.01
  53.  *
  54.  * Revision 1.2  1991/09/11  12:07:05  pab
  55.  * 11/9/91 First Alpha release of modified system
  56.  *
  57.  * Revision 1.1  1991/08/12  16:49:30  pab
  58.  * Initial revision
  59.  *
  60.  * Revision 1.10  1991/06/17  19:05:23  pab
  61.  * altered set_assoc to eval properly.
  62.  *
  63.  * Revision 1.8  1991/02/13  18:18:53  kjp
  64.  * Pass.
  65.  *
  66.  */
  67.  
  68. #define KJPDBG(x) 
  69. #define INOUT(x)
  70. #define CLASSBUG(x) /* fprintf(stderr,"CLASSBUG:");x;fflush(stderr) */
  71.  
  72. /*
  73.  * Change Log:
  74.  *   Version 1, June 1989
  75.  *   Version N ( N >> 1 ), November 1989
  76.  */
  77.  
  78. #include <stdio.h>
  79. #include "defs.h"
  80. #include "structs.h"
  81.  
  82. #include "funcalls.h"
  83.  
  84. #include "global.h"
  85. #include "error.h"
  86.  
  87. #include "class.h"
  88. #include "vectors.h" 
  89. #include "table.h"   
  90. #include "bootstrap.h"
  91. #include "slots.h"
  92. #include "ngenerics.h"
  93. #include "modules.h"
  94. #include "modboot.h"
  95. #include "symboot.h"
  96. #include "garbage.h"
  97.  
  98. #define CLASSES_ENTRIES 63
  99. MODULE Module_classes;
  100. static LispObject classes_module; /* Utter hack, Module_x no longer useful */
  101. LispObject Module_classes_values[CLASSES_ENTRIES];
  102.  
  103. #define is_class(c) (typeof(c) == TYPE_CLASS)
  104. #define MYCONS(a,b)   EUCALL_2(Fn_cons,a,b)
  105.  
  106. extern LispObject Basic_Structure;
  107. extern LispObject Primitive_Class;
  108.  
  109. extern void set_anon_associate(LispObject*,LispObject,LispObject);
  110.  
  111. /* Internal symbols... */
  112.  
  113. static LispObject sym_direct_superclasses;
  114. static LispObject sym_direct_slot_descriptions;
  115. static LispObject sym_metaclass_hypotheses;
  116.  
  117. static LispObject sym_slot_class;
  118. static LispObject sym_slot_initargs;
  119.  
  120. static LispObject sym_predicate;
  121.  
  122. /* Functions... */
  123.  
  124. LispObject Fn_make_predicate(LispObject*);
  125.  
  126. /*
  127.  
  128.  * These are the class object accessor functions.
  129.  * At level-1 or above, most of these must be generic but at level-0 
  130.  * it is unnecesary
  131.  *
  132.  * All of the below assumes single inheritance - must change any piece
  133.  * of generic code referencing CLASS.superclass
  134.  
  135.  */
  136.  
  137. EUFUN_1( Fn_classp, class)
  138. {
  139.   LispObject Fn_subclassp(LispObject*);
  140.   RETURN_EUCALL(EUCALL_2(Fn_subclassp,classof(class),Standard_Class)); 
  141. }
  142. EUFUN_CLOSE
  143.  
  144. EUFUN_1( Fn_class_of, object)
  145. {
  146.   return(classof(object));
  147. }
  148. EUFUN_CLOSE
  149.  
  150. EUFUN_2( Fn_subclassp, sub, class)
  151. {
  152.   LispObject walker;
  153.  
  154.   if (sub == nil) return(nil);
  155.   if (sub == class) return(sub); /* Used to say lisptrue which is wrong */
  156.  
  157.   walker = sub->CLASS.superclasses;
  158.   while(is_cons(walker)) {
  159.     STACK_TMP(CDR(walker));
  160.     if (EUCALL_2(Fn_subclassp,CAR(walker),ARG_1(stackbase)) != nil)
  161.       return(ARG_0(stackbase));
  162.     else
  163.       UNSTACK_TMP(walker);
  164.   }
  165.  
  166.   return(nil);
  167. }
  168. EUFUN_CLOSE
  169.  
  170. EUFUN_1( Fn_class_name, class)
  171. {
  172.   if (EUCALL_2(Fn_subclassp,classof(class),Standard_Class) == nil)
  173.     CallError(stacktop,"class-name: not a class",ARG_0(stackbase),NONCONTINUABLE);
  174.  
  175.   return(ARG_0(stackbase)->CLASS.name);
  176. }
  177. EUFUN_CLOSE
  178.  
  179. EUFUN_1( Fn_class_precedence_list, class)
  180. {
  181.   if (typeof(class) != TYPE_CLASS)
  182.     CallError(stacktop,
  183.           "class-precedence-list: non class",class,NONCONTINUABLE);
  184.  
  185.   return(class->CLASS.precedence);
  186. }
  187. EUFUN_CLOSE
  188.  
  189. EUFUN_1( Fn_class_prototype, class)
  190. {
  191.   if (typeof(class) != TYPE_CLASS)
  192.     CallError(stacktop,"class-prototype: not a class",class,NONCONTINUABLE);
  193.   fprintf(stderr,"Class-prototype: No such function\n");
  194.  
  195.   return nil;
  196. }
  197. EUFUN_CLOSE
  198.  
  199. LispObject generic_compute_class_precedence_list;
  200.  
  201. EUFUN_1( Gf_compute_class_precedence_list, c)
  202. {
  203.   return(generic_apply_1(stacktop,generic_compute_class_precedence_list,c));
  204. }
  205. EUFUN_CLOSE
  206.  
  207. EUFUN_1( Md_compute_class_precedence_list_Class, class)
  208. {
  209.   LispObject walker,result;
  210.  
  211.   if (typeof(class) != TYPE_CLASS)
  212.     CallError(stacktop,
  213.           "compute-class-precedence-list: non class",class,NONCONTINUABLE);
  214.  
  215.   walker = class; result = nil;
  216.  
  217.   while (walker != nil) {
  218.     LispObject super, xx;
  219.  
  220.     STACK_TMP(walker);
  221.     STACK_TMP(result);
  222.     EUCALLSET_2(xx, Fn_cons, walker, nil);
  223.     UNSTACK_TMP(result);
  224.     EUCALLSET_2(result, Fn_nconc, result, xx);
  225.     UNSTACK_TMP(walker);
  226.     super = walker->CLASS.superclasses;
  227.     if (super == nil) 
  228.       walker = nil;
  229.     else if (is_cons(CDR(super)))
  230.       CallError(stacktop,"compute-class-precedence-list: mi class",class,
  231.         NONCONTINUABLE);
  232.     else
  233.       walker = CAR(super);
  234.   }
  235.  
  236.   return(result);
  237. }
  238. EUFUN_CLOSE
  239.  
  240. EUFUN_1( Fn_class_direct_superclasses, class)
  241. {
  242.   if (typeof(class) != TYPE_CLASS) 
  243.     CallError(stacktop,
  244.           "class-direct-superclasses: non class",class,NONCONTINUABLE);
  245.  
  246.   return(class->CLASS.superclasses);
  247. }
  248. EUFUN_CLOSE
  249.  
  250. EUFUN_1( Fn_class_direct_subclasses, class)
  251. {
  252.   if (typeof(class) != TYPE_CLASS) 
  253.     CallError(stacktop,
  254.           "class-direct-subclasses: non class",class,NONCONTINUABLE);
  255.  
  256.   return(class->CLASS.subclasses);
  257. }
  258. EUFUN_CLOSE
  259.  
  260. EUFUN_1( Fn_class_slot_descriptions, class)
  261. {
  262.   if (typeof(class) != TYPE_CLASS) 
  263.     CallError(stacktop,
  264.           "class-slot-descriptions: non class",class,NONCONTINUABLE);
  265.  
  266.   return(class->CLASS.slot_list);
  267. }
  268. EUFUN_CLOSE
  269.  
  270. EUFUN_1( Fn_class_direct_slot_descriptions, class)
  271. {
  272.   if (typeof(class) != TYPE_CLASS) 
  273.     CallError(stacktop,
  274.           "class-slot-descriptions: non class",class,NONCONTINUABLE);
  275.  
  276.   /* HACK !!! Wrong !! */
  277.  
  278.   return(class->CLASS.direct_slot_list);
  279. }
  280. EUFUN_CLOSE
  281.  
  282. /*
  283.  * Slot access protocol...
  284.  */
  285.  
  286. /* Generic slot-value-using-class */
  287.  
  288. LispObject generic_slot_value_using_class;
  289.  
  290. EUFUN_3( Gf_slot_value_using_class, c, o, p)
  291. {
  292.   return(generic_apply_3(stacktop,generic_slot_value_using_class,c,o,p));
  293. }
  294. EUFUN_CLOSE
  295.  
  296. EUFUN_3( Md_slot_value_using_class_Structure_Class, class, obj, pos)
  297. {
  298.   return(slotref(obj,intval(pos)));
  299. }
  300. EUFUN_CLOSE
  301.  
  302. EUFUN_3( Md_slot_value_using_class_Standard_Class, class, obj, pos)
  303. {
  304.   return(slotref(obj,intval(pos)));
  305. }
  306. EUFUN_CLOSE
  307.  
  308. LispObject generic_slot_value_using_class_setter;
  309.  
  310. /* You know, some people actually USE the value of these things :-( */
  311. EUFUN_4( Md_slot_value_using_class_setter_Structure_Class, class, obj, pos, val)
  312. {
  313.   LispObject tmp;
  314.   
  315.   slotrefupdate(obj,intval(pos),val);
  316.  
  317.   return val;
  318. }
  319. EUFUN_CLOSE
  320.  
  321. EUFUN_4( Md_slot_value_using_class_setter_Standard_Class, class, obj, pos, val)
  322. {
  323.   slotrefupdate(obj,intval(pos),val);
  324.  
  325.   return val;
  326. }
  327. EUFUN_CLOSE
  328.  
  329. LispObject generic_slot_value_using_slot_description;
  330.  
  331. EUFUN_2( Md_slot_value_using_slot_description_Local_Slot_Description,
  332.      obj, desc)
  333. {
  334.   LispObject xx;
  335.   EUCALLSET_1(xx, Fn_class_of, obj); /* CANNOT GC */
  336.   return(generic_apply_3(stacktop,generic_slot_value_using_class,
  337.              xx,
  338.              obj,
  339.              slot_desc_position(desc)));
  340. }
  341. EUFUN_CLOSE
  342.  
  343. LispObject generic_slot_value_using_slot_description_setter;
  344.  
  345. EUFUN_3( 
  346.   Md_slot_value_using_slot_description_setter_Local_Slot_Description,
  347.     obj, desc, val)
  348. {
  349.   LispObject xx;
  350.   EUCALLSET_1(xx, Fn_class_of, obj); /* CANNOT GC */
  351.   return(generic_apply_4(stacktop,generic_slot_value_using_class_setter,
  352.              xx, obj, slot_desc_position(desc), val));
  353. }
  354. EUFUN_CLOSE
  355.  
  356. LispObject generic_find_slot_description;
  357.  
  358. EUFUN_2( Gf_find_slot_description, c, n)
  359. {
  360.   return(generic_apply_2(stacktop,generic_find_slot_description,c,n));
  361. }
  362. EUFUN_CLOSE
  363.  
  364. EUFUN_2( Md_find_slot_description_Structure_Class, class, name)
  365. {
  366.   LispObject desc;
  367.  
  368.   EUCALLSET_2(desc, Fn_find_slot_description,class,name);
  369.  
  370.   if (desc == nil)
  371.     CallError(stacktop,
  372.           "find-slot-description: slot missing",
  373.           ARG_1(stackbase),NONCONTINUABLE);
  374.  
  375.   return(desc);
  376. }
  377. EUFUN_CLOSE
  378.  
  379.  
  380. EUFUN_2( Md_find_slot_description_Standard_Class, class, name)
  381. {
  382.   LispObject desc;
  383.  
  384.   EUCALLSET_2(desc, Fn_find_slot_description,class,name);
  385.  
  386.   if (desc == nil)
  387.     CallError(stacktop,"find-slot-description: slot missing",
  388.           ARG_1(stackbase),NONCONTINUABLE);
  389.  
  390.   return(desc);
  391. }
  392. EUFUN_CLOSE
  393.  
  394. EUFUN_2( Fn_slot_value, obj, slotname)
  395. {
  396.   LispObject desc;
  397.   LispObject xx;
  398.   
  399.   xx=classof(obj);
  400.   desc = generic_apply_2(stacktop,generic_find_slot_description,
  401.              xx, slotname);
  402.  
  403.   return(generic_apply_2(stacktop,generic_slot_value_using_slot_description,
  404.              ARG_0(stackbase),desc));
  405. }
  406. EUFUN_CLOSE
  407.  
  408.  
  409. EUFUN_3( Fn_slot_value_setter, obj, slotname, val)
  410. {
  411.   LispObject desc;
  412.   LispObject xx;
  413.   xx=classof(obj);
  414.  
  415.   desc = generic_apply_2(stacktop,generic_find_slot_description,
  416.              xx, slotname);
  417.  
  418.   return(generic_apply_3(stacktop,
  419.              generic_slot_value_using_slot_description_setter,
  420.              ARG_0(stackbase),desc,ARG_2(stackbase)));
  421. }
  422. EUFUN_CLOSE
  423.  
  424. /*
  425.  
  426.  * The inheritance protocol...
  427.  
  428.  */
  429.  
  430. EUFUN_3( Fn_add_superclasses, class, supers, slotsinitargs)
  431. {
  432.   LispObject walker,xx;
  433.  
  434.   /* fprintf(stderr,"add-supers: \n"); fflush(stderr); */
  435.  
  436.   if (typeof(class) != TYPE_CLASS)
  437.     CallError(stacktop,"add-superclasses: non class",class,NONCONTINUABLE);
  438.  
  439.   if (EUCALL_2(Fn_subclassp,classof(class),Standard_Class) == nil)
  440.     CallError(stacktop,"add-superclasses: non structure-class",
  441.           class,NONCONTINUABLE);
  442.  
  443.   /* Perform the 'add-subclass' calls on the supers - checks compatability */
  444.   /* Backtracking's a problem... */
  445.  
  446.   walker = supers;
  447.   while (is_cons(walker)) {
  448.     STACK_TMP(CDR(walker));
  449.     EUCALL_2(Fn_add_subclass,ARG_0(stackbase),CAR(walker));
  450.     UNSTACK_TMP(walker);
  451.   }
  452.  
  453.   /* Do precedence list... */
  454.  
  455.   class = ARG_0(stackbase);
  456.   EUCALLSET_1(xx,
  457.           Gf_compute_class_precedence_list,class); 
  458.   ARG_0(stackbase)->CLASS.precedence=xx;
  459.   class = ARG_0(stackbase); slotsinitargs=ARG_2(stackbase); 
  460.   EUCALL_2(Fn_collect_slots,class,slotsinitargs);
  461.   
  462.   return(ARG_0(stackbase));
  463. }
  464. EUFUN_CLOSE
  465.  
  466. EUFUN_2( Fn_add_subclass, class, super)
  467. {
  468.   extern LispObject Fn_nconc(LispObject*);
  469.   LispObject xx;
  470.  
  471. /* fprintf(stderr,"add-sub: \n"); fflush(stderr); */
  472.  
  473.   if (EUCALL_2(Fn_metaclass_compatibility,class,super) == nil)
  474.     CallError(stacktop,
  475.           "add-subclass: incompatible metaclasses",super,NONCONTINUABLE);
  476.  
  477.   /* Just mark the new class - change the existing ones later */
  478.  
  479.   super = ARG_1(stackbase);
  480.   EUCALLSET_2(xx,Fn_cons,super,nil);
  481.   class = ARG_0(stackbase);
  482.   EUCALLSET_2(xx,Fn_nconc,class->CLASS.superclasses,xx);
  483.   class = ARG_0(stackbase);
  484.   class->CLASS.superclasses = xx;
  485.   super = ARG_1(stackbase);
  486.   class->CLASS.local_count = super->CLASS.local_count;
  487.  
  488.   /* If we're all must have gone OK so now mark the existing class(es) */
  489.   /* Should be in a less haphazard order for multiple inheritance !!   */
  490.  
  491.   EUCALLSET_2(xx, Fn_cons, class, super->CLASS.subclasses);
  492.   super = ARG_1(stackbase);
  493.   super->CLASS.subclasses = xx;
  494.  
  495.   class = ARG_0(stackbase);
  496.   return(class);
  497. }
  498. EUFUN_CLOSE
  499.  
  500. EUFUN_2( Fn_metaclass_compatibility, class, super)
  501. {
  502.  
  503. /* fprintf(stderr,"compatability: \n"); fflush(stderr); */
  504.  
  505.   if (!is_class(class))
  506.     CallError(stacktop,
  507.           "metaclass-compatibility: non class",class,NONCONTINUABLE);
  508.  
  509.   if (!is_class(super))
  510.     CallError(stacktop,
  511.           "metaclass-compatibility: non class",super,NONCONTINUABLE);
  512.  
  513.   RETURN_EUCALL(EUCALL_2(Fn_subclassp,classof(class),classof(super)));
  514. }
  515. EUFUN_CLOSE
  516.  
  517. LispObject generic_add_slot_description;
  518.  
  519. EUFUN_2( Gf_add_slot_description, c, desc)
  520. {
  521.   return(generic_apply_2(stackbase,generic_add_slot_description,c,desc));
  522. }
  523. EUFUN_CLOSE
  524.  
  525. EUFUN_2( Md_add_slot_description_Class_Slot_Description, class, desc)
  526. {
  527.   LispObject xx;
  528.   if (class->CLASS.slot_table == nil) {
  529.     (ARG_0(stackbase))->CLASS.slot_table =
  530.       (LispObject) allocate_table(stacktop,Fn_eq);
  531.     class = ARG_0(stackbase);
  532.     desc=ARG_1(stackbase);
  533.   }
  534.  
  535.   EUCALL_3(tref_updator,class->CLASS.slot_table,
  536.               slot_desc_name(desc),desc);
  537.   class = ARG_0(stackbase);
  538.   desc = ARG_1(stackbase);
  539.   EUCALLSET_2(xx,Fn_cons,desc,class->CLASS.slot_list);
  540.   class = ARG_0(stackbase);
  541.   class->CLASS.slot_list = xx;
  542.  
  543.   return(class);
  544. }
  545. EUFUN_CLOSE
  546.  
  547. EUFUN_2( Md_add_slot_description_Class_Local_Slot_Description, class, desc)
  548. {
  549.   if (slot_desc_position(desc) == unbound)
  550.     {
  551.       slot_desc_position(desc) = real_allocate_integer(stacktop,(class->CLASS.local_count++));
  552.       class=ARG_0(stackbase);
  553.       desc=ARG_1(stackbase);
  554.     }
  555.   RETURN_EUCALL(EUCALL_2(Md_add_slot_description_Class_Slot_Description,class,desc));
  556. }
  557. EUFUN_CLOSE
  558.  
  559. static LispObject find_superclass_slot_description(LispObject *stacktop,
  560.                            LispObject c,
  561.                            LispObject name)
  562. {
  563.   LispObject walker,desc;
  564.  
  565.   walker = c->CLASS.superclasses;
  566.   while (is_cons(walker)) {
  567.     STACK_TMP(CDR(walker));
  568.     STACK_TMP(name);
  569.     EUCALLSET_2(desc, Fn_find_slot_description,CAR(walker),name);
  570.     if (desc != nil) return(desc);
  571.     UNSTACK_TMP(name);
  572.     UNSTACK_TMP(walker);
  573.   }
  574.  
  575.   return(nil);
  576. }
  577.  
  578. static LispObject superclass_slot_descriptions(LispObject *stacktop,LispObject c)
  579. {
  580.   extern EUDECL( Fn_append);
  581.   LispObject all,walker;
  582.   
  583.   STACK_TMP(c);
  584.  
  585.   walker = c->CLASS.superclasses; all = nil;
  586.   while(is_cons(walker)) {
  587.     all = EUCALL_2(Fn_append,all,CAR(walker)->CLASS.slot_list);
  588.     walker = CDR(walker);
  589.   }
  590.   
  591.   UNSTACK_TMP(c);
  592.  
  593.   return(all);
  594. }
  595.  
  596. EUFUN_2( Fn_collect_slots, class, slots_initlist)
  597. {
  598.   LispObject allslots = nil;
  599.  
  600.   if (!is_class(class))
  601.     CallError(stacktop,"collect-slots: non class",class,NONCONTINUABLE);
  602.  
  603.   if (EUCALL_2(Fn_subclassp,classof(class),Standard_Class) == nil)
  604.     CallError(stacktop,"collect-slots: non class",class,NONCONTINUABLE);
  605.  
  606.   /* Collect the slots in such a way that for simple single 
  607.      inheritance, slot position is preserved...             */
  608.  
  609.   /* Bleargh!! Make the slots referenced in the initlist */
  610.  
  611.   while (is_cons(slots_initlist)) {
  612.     LispObject desc;
  613.     STACK_TMP(CDR(slots_initlist));
  614.     class=ARG_0(stackbase);
  615.     EUCALLSET_2(desc,Gf_make_slot_description,class,CAR(slots_initlist));
  616.     class=ARG_0(stackbase);
  617.     EUCALL_2(Gf_add_slot_description,class,desc);
  618.  
  619.     UNSTACK_TMP(slots_initlist);
  620.   }
  621.  
  622.   /* Now do any as yet uninherited... */
  623.  
  624.   allslots = superclass_slot_descriptions(stacktop,ARG_0(stackbase)/*class*/);
  625.   class=ARG_0(stackbase);
  626.   while (is_cons(allslots)) {
  627.     LispObject newdesc,oldesc;
  628.     
  629.     STACK_TMP(CDR(allslots));
  630.     oldesc = CAR(allslots);
  631.     STACK_TMP(oldesc);
  632.     EUCALLSET_2(newdesc,Fn_find_slot_description,
  633.         class,slot_desc_name(oldesc));
  634.     UNSTACK_TMP(oldesc);
  635.     if (newdesc == nil) {
  636.       EUCALLSET_3(newdesc, Gf_make_inherited_slot_description,
  637.           class,oldesc,nil);
  638.       class=ARG_0(stackbase);
  639.       EUCALL_2(Gf_add_slot_description,class,newdesc);
  640.     }
  641.     UNSTACK_TMP(allslots);
  642.     class=ARG_0(stackbase);
  643.   }
  644.  
  645.   return(class);
  646. }
  647. EUFUN_CLOSE
  648.  
  649. LispObject generic_make_slot_description;
  650.  
  651. EUFUN_2( Gf_make_slot_description, c, l)
  652. {
  653.   return(generic_apply_2(stacktop,generic_make_slot_description,c,l));
  654. }
  655. EUFUN_CLOSE
  656.  
  657. EUFUN_2( Md_make_slot_description_Class, class, plist)
  658. {
  659.   LispObject desc,slot_name,slot_class;
  660.   LispObject ret,xx;
  661.  
  662.   /* Search the initargs for specified... else default */
  663.  
  664.   slot_name = search_keylist(stacktop,plist,sym_name);
  665.   if (slot_name == unbound)
  666.     CallError(stacktop,"make-slot-description: slot name missing",plist,NONCONTINUABLE);
  667.   
  668.   STACK_TMP(slot_name);
  669.   desc = find_superclass_slot_description(stacktop,class,slot_name);
  670.   if (desc != nil) {
  671.     class=ARG_0(stackbase);
  672.     plist=ARG_1(stackbase);
  673.     RETURN_EUCALL(EUCALL_3(Gf_make_inherited_slot_description,class
  674.                ,desc,plist));
  675.   }
  676.   UNSTACK_TMP(slot_name);
  677.   plist=ARG_1(stackbase);
  678.   slot_class = search_keylist(stacktop,plist,sym_slot_class);
  679.  
  680.   if (slot_class == unbound) 
  681.     CallError(stacktop,"make-slot-description: missing slot class ",
  682.           plist,NONCONTINUABLE);
  683.   /* Generate the position as necessary */
  684.  
  685.   if (EUCALL_2(Fn_subclassp,slot_class,Slot_Description) == nil)
  686.     CallError(stacktop,"make-slot-description: invalid slot class",
  687.           slot_class,NONCONTINUABLE);
  688.  
  689.   /* Something of a hack but still... */
  690.  
  691.   EUCALLSET_2(ret,Gf_make_instance,slot_class,plist);
  692.   class=ARG_0(stackbase);
  693.   STACK_TMP(ret);
  694.   xx=MYCONS(ret,class->CLASS.direct_slot_list);
  695.   UNSTACK_TMP(ret);
  696.   class=ARG_0(stackbase);
  697.   class->CLASS.direct_slot_list = xx;
  698.  
  699.   return(ret);
  700. }
  701. EUFUN_CLOSE
  702.  
  703. LispObject generic_make_inherited_slot_description;
  704.  
  705. EUFUN_3( Gf_make_inherited_slot_description, c, d, l)
  706. {
  707.   return(generic_apply_3(stacktop,generic_make_inherited_slot_description,c,d,l));
  708. }
  709. EUFUN_CLOSE
  710.  
  711. EUFUN_3( Md_make_inherited_slot_description_Class_Slot_Description, class, oldesc, plist)
  712. {
  713.   extern LispObject generic_allocate_instance;
  714.   LispObject slot_class;
  715.   LispObject newdesc;
  716.  
  717.   IGNORE(class); /* Strange but true... */
  718.  
  719.   slot_class = classof(oldesc);
  720.  
  721.   newdesc = generic_apply_2(stacktop,generic_allocate_instance,slot_class,nil);
  722.   EUCALLSET_3(newdesc, Fn_inherit_slot_details,
  723.           newdesc,/*oldesc*/ARG_1(stackbase),/*plist*/ARG_2(stackbase));
  724.  
  725.   return(newdesc);
  726. }
  727. EUFUN_CLOSE
  728.  
  729. EUFUN_3( Fn_inherit_slot_details, newdesc, oldesc, plist)
  730. {
  731.   LispObject modifier;
  732.  
  733.   /* Should be generic I suppose */
  734.  
  735.   /* For local slot descriptions */
  736.  
  737.   if (EUCALL_2(Fn_subclassp,classof(newdesc),Slot_Description) == nil)
  738.     CallError(stacktop,"inherit-slot-details: non local slot description",
  739.           newdesc,NONCONTINUABLE);
  740.  
  741.   if (EUCALL_2(Fn_subclassp,classof(oldesc),Slot_Description) == nil)
  742.     CallError(stacktop,"inherit-slot-details: non local slot description",
  743.           oldesc,NONCONTINUABLE);
  744.  
  745.   /* All local - all cool... */
  746.  
  747.   /* Inherit as is - modify as necessary */
  748.  
  749.   /* Merge initargs... */
  750.  
  751.   slot_desc_initargs(newdesc) = slot_desc_initargs(oldesc);
  752.   modifier = search_keylist(stacktop,plist,sym_initargs);
  753.   if (modifier != unbound) {
  754.     if (slot_desc_initargs(oldesc) == unbound)
  755.       slot_desc_initargs(newdesc) = modifier;
  756.     else
  757.       EUCALLSET_2(slot_desc_initargs(newdesc),
  758.           Fn_nconc,modifier,slot_desc_initargs(newdesc));
  759.   }
  760.     
  761.   /* Merge initforms... */
  762.  
  763.   slot_desc_initform(newdesc) = slot_desc_initform(oldesc);
  764.   modifier = search_keylist(stacktop,plist,sym_initform);
  765.   if (modifier != unbound) slot_desc_initform(newdesc) = modifier;
  766.  
  767.   /* Just take name and position direct at level-0 */
  768.   
  769.   slot_desc_name(newdesc)     = slot_desc_name(oldesc);
  770.   slot_desc_position(newdesc) = slot_desc_position(oldesc);
  771.   slot_desc_mutable(newdesc)  = slot_desc_mutable(oldesc);
  772.   
  773.   return(newdesc);
  774. }
  775. EUFUN_CLOSE
  776.  
  777. /*
  778.  
  779.  * Instance generation... 
  780.  
  781.  */
  782.  
  783. /* GENERIC FUNCTION 'allocate_instance' */
  784.  
  785. LispObject generic_allocate_instance;
  786.  
  787. /* Standard-Class */
  788. EUFUN_2( Md_allocate_instance_1, class, initlist)
  789. {
  790.   LispObject new;
  791.  
  792.   IGNORE(initlist);
  793.  
  794.   if (EUCALL_2(Fn_subclassp,class,Standard_Class) != nil) {
  795.     new = (LispObject) allocate_class(stacktop,class);
  796.     STACK_TMP(new);
  797.     new->CLASS.slot_table = (LispObject) allocate_table(stacktop,Fn_eq);
  798.     UNSTACK_TMP(new);
  799.   }
  800.   else {
  801.     new = (LispObject) allocate_instance(stacktop,class);
  802.   }
  803.  
  804.   return(new);
  805. }
  806. EUFUN_CLOSE
  807.  
  808. /* Structure-Class */
  809. EUFUN_2( Md_allocate_instance_2, class, initlist)
  810. {
  811.   LispObject inst;
  812.  
  813.   inst = (LispObject) allocate_instance(stacktop,class);
  814.  
  815.   class=ARG_0(stackbase);
  816.   {
  817.     int i;
  818.     for(i=0; i<class->CLASS.local_count; i++)
  819.       slotref(inst,i) = unbound;
  820.   }
  821.  
  822.   return(inst);
  823. }
  824. EUFUN_CLOSE
  825.  
  826. /* Slot_Description_Class */
  827. EUFUN_2( Md_allocate_instance_3, class, initlist)
  828. {
  829.   LispObject inst;
  830.   
  831.   inst = (LispObject) allocate_instance(stacktop,class);
  832.  
  833.   slot_desc_mutable(inst) = lisptrue;
  834.  
  835.   {
  836.     int i;
  837.     for(i=0; i<class->CLASS.local_count; i++)
  838.       slotref(inst,i) = unbound;
  839.   }
  840.  
  841.   return(inst);
  842. }
  843. EUFUN_CLOSE
  844.  
  845. extern LispObject Condition_Class;
  846.  
  847. /* Condition-Class */
  848. EUFUN_2( Md_allocate_instance_4, class, initlist)
  849. {
  850.   LispObject cond;
  851.  
  852.   cond = (LispObject) allocate_instance(stacktop,class);
  853.  
  854.   {
  855.     int i;
  856.     for(i=0; i<class->CLASS.local_count; i++)
  857.       slotref(cond,i) = unbound;
  858.   }
  859.   return(cond);
  860. }
  861. EUFUN_CLOSE
  862.  
  863. /* Primitive classes */
  864. EUFUN_2( Md_allocate_instance_Primitive_Class, c, l)
  865. {
  866.   CallError(stacktop,"allocate-instance: can't allocate primitive",c,NONCONTINUABLE);
  867.   return(nil);
  868. }
  869. EUFUN_CLOSE
  870.  
  871. EUFUN_3( Fn_fill_slot, desc, obj, initlist)
  872. {
  873.   LispObject initargs,key,value = unbound;
  874.  
  875.   if (EUCALL_2(Fn_subclassp,classof(desc),Slot_Description) == nil) 
  876.     CallError(stacktop,"fill-slot: invalid slot description",desc,NONCONTINUABLE);
  877.  
  878.   initargs = slot_desc_initargs(desc);
  879.   while(is_cons(initargs)) {
  880.     key = CAR(initargs); initargs = CDR(initargs);
  881.     value = search_keylist(stacktop,initlist,key);
  882.     if (value != unbound) break;
  883.   }
  884.  
  885.   if (value != unbound) {
  886.     (void) generic_apply_3(stacktop,generic_slot_value_using_slot_description_setter,
  887.                obj,desc,value);
  888.   }
  889.   else {
  890.     if (slot_desc_initform(desc) != unbound) {
  891.       LispObject xx;
  892.       extern LispObject Fn_apply(LispObject*);
  893.  
  894.       EUCALLSET_2(xx, Fn_apply,slot_desc_initform(desc),nil);
  895.       (void) generic_apply_3(stacktop,generic_slot_value_using_slot_description_setter,
  896.                  ARG_1(stackbase)/*obj*/,ARG_0(stackbase)/*desc*/,
  897.                  xx);
  898.                              /* Should be other... */
  899.  
  900.     }
  901.   }
  902.   
  903.   return(ARG_1(stackbase));
  904. }
  905. EUFUN_CLOSE
  906.  
  907.  
  908. /* GENERIC FUNCTION 'initialize_instance' */  
  909.  
  910. LispObject generic_initialize_instance;
  911.  
  912. /* Object */
  913. EUFUN_2( Md_initialize_instance_1, obj, initlist)
  914. {
  915.   LispObject class = classof(obj);
  916.   LispObject local_slots;
  917.  
  918.   CLASSBUG(fprintf(stderr,"init-inst: structure\n"));
  919.  
  920.   /* OK - initialize strategy is - take each local slot in turn.
  921.                                    get it's instance description.
  922.                    if it has initargs, search the initlist.
  923.                    failing that use initform.
  924.                    failing THAT leave unbound. */
  925.  
  926.   /* Should get a more efficient table stepper one day but ... */
  927.  
  928.   EUCALLSET_1(local_slots, Fn_class_slot_descriptions,class); 
  929.  
  930.   /* Tryin' it with all slots */
  931.  
  932.   while (local_slots != nil) {
  933.     LispObject desc = CAR(local_slots);
  934.     
  935.     CLASSBUG(fprintf(stderr,"init-inst: structure, filling...\n"));
  936.     STACK_TMP(CDR(local_slots));
  937.     obj=ARG_0(stackbase); initlist=ARG_1(stackbase);
  938.     EUCALL_3(Fn_fill_slot,desc,obj,initlist);
  939.     UNSTACK_TMP(local_slots);
  940.   }
  941.  
  942.   obj=ARG_0(stackbase);
  943.   return(obj);
  944. }
  945. EUFUN_CLOSE
  946.  
  947. /* Standard-Class */
  948. EUFUN_2( Md_initialize_instance_2, obj, initlist)
  949. {
  950.   LispObject name,superclass,slot_descriptions;
  951.  
  952.   obj=EUCALL_2(Md_initialize_instance_1,obj,initlist); /* Other slots... */
  953.   initlist=ARG_1(stackbase);
  954.   name = search_keylist(stacktop,initlist,sym_name);
  955.   if (name == unbound) name = sym_anonymous_class;
  956.   superclass = search_keylist(stacktop,initlist,sym_direct_superclasses);
  957.  
  958.   ARG_0(stackbase)=obj;
  959.   if (superclass == unbound) 
  960.     {
  961.       STACK_TMP(name);
  962.       STACK_TMP(superclass);
  963.       EUCALLSET_2(superclass, Fn_cons,Object,nil);
  964.       UNSTACK_TMP(superclass);
  965.       UNSTACK_TMP(name);
  966.     }    
  967.  
  968.   if (!is_cons(superclass))
  969.     CallError(stacktop,"initialize-instance: bad superclasses",
  970.           superclass,NONCONTINUABLE);
  971.   obj=ARG_0(stackbase); initlist=ARG_1(stackbase);
  972.   slot_descriptions = search_keylist(stacktop,initlist,sym_direct_slot_descriptions);
  973.   if (slot_descriptions == unbound) slot_descriptions = nil;
  974.  
  975.   /* Do inheritance & initialization */
  976.  
  977.   obj->CLASS.name = name;
  978.  
  979.   /* These don't do what they're supposed to */
  980.   /* In fact currently they just add the parent/children info */
  981.  
  982.   EUCALL_3(Fn_add_superclasses,obj,superclass,slot_descriptions);
  983.   obj=ARG_0(stackbase);
  984.  
  985.   return(obj);
  986.  
  987. }
  988. EUFUN_CLOSE
  989.  
  990. /* Slot_Description */
  991. EUFUN_2( Md_initialize_instance_3, obj, initlist)
  992. {
  993.   LispObject name,position,initargs,initform,mutable;
  994.  
  995.   name = search_keylist(stacktop,initlist,sym_name);
  996.   if (name == unbound)
  997.     CallError(stacktop,"initialize-instance: no name for slot description",
  998.           unbound,NONCONTINUABLE);
  999.  
  1000.   position = search_keylist(stacktop,initlist,sym_position);
  1001.   initargs = search_keylist(stacktop,initlist,sym_initargs);
  1002.   initform = search_keylist(stacktop,initlist,sym_initform);
  1003.   mutable  = search_keylist(stacktop,initlist,sym_mutable);
  1004.  
  1005.   /* Should verify... */
  1006.  
  1007.   slot_desc_name(obj) = name;
  1008.   slot_desc_position(obj) = position;
  1009.   slot_desc_initargs(obj) = initargs;
  1010.   slot_desc_initform(obj) = initform;
  1011.   slot_desc_mutable(obj) = (mutable == nil ? nil : lisptrue);
  1012.  
  1013.   RETURN_EUCALL(EUCALL_2(Md_initialize_instance_1,obj,initlist));
  1014. }
  1015. EUFUN_CLOSE
  1016.  
  1017. extern LispObject Default_Condition;
  1018.  
  1019. /* Default-Condition */
  1020. EUFUN_2( Md_initialize_instance_4, obj, initlist)
  1021. {
  1022.   LispObject message,value;
  1023.  
  1024.   message = search_keylist(stacktop,initlist,sym_message);
  1025.   if (message == unbound) message = nil;
  1026.   value = search_keylist(stacktop,initlist,sym_error_value);
  1027.   condition_message(obj) = message;
  1028.   condition_error_value(obj) = value;
  1029.  
  1030.   RETURN_EUCALL(EUCALL_2(Md_initialize_instance_1,obj,initlist));
  1031. }
  1032. EUFUN_CLOSE
  1033.  
  1034. /* A would-be generic... */
  1035.  
  1036. EUFUN_2( Gf_make_instance, class, initargs)
  1037. {
  1038.   LispObject obj;
  1039.  
  1040.   obj = generic_apply_2(stacktop,generic_allocate_instance,class,initargs);
  1041.   initargs=ARG_1(stackbase);
  1042.   obj = generic_apply_2(stackbase,generic_initialize_instance,obj,initargs);
  1043.  
  1044.   return(obj);
  1045. }
  1046. EUFUN_CLOSE
  1047.  
  1048. /*
  1049.  
  1050.  * The defstruct stuff...
  1051.  
  1052.  */
  1053.  
  1054. /* Keylist utilities... */
  1055.  
  1056. /* Searches through alternating symbol/value slot option lists for opname */
  1057.   
  1058. LispObject search_option(LispObject opname,LispObject oplist)
  1059. {
  1060.   if (oplist == nil) return(unbound);
  1061.   if (CAR(oplist) == opname) return(CAR(CDR(oplist)));
  1062.   return(search_option(opname,CDR(CDR(oplist))));
  1063. }
  1064.  
  1065. /* Does the same thing more robustly... */
  1066.  
  1067. LispObject search_keylist(LispObject *stacktop,LispObject list,LispObject key)
  1068. {
  1069.   int i=0;
  1070.   LispObject ptr;
  1071.  
  1072.   if (list != nil && !is_cons(list))
  1073.     CallError(stacktop,"invalid key list",list,NONCONTINUABLE);
  1074.   
  1075.   ptr=list;
  1076.   while (ptr!=nil)
  1077.     { i++;
  1078.       ptr=CDR(ptr);
  1079.     }
  1080.  
  1081.   if (i%2 != 0)
  1082.     CallError(stacktop,"unbalanced initlist",list,NONCONTINUABLE);
  1083.  
  1084.  
  1085.   while(list != nil) {
  1086.     LispObject lkey = CAR(list);
  1087.     LispObject lval = CAR(CDR(list));
  1088.     
  1089.     if (key == lkey) return(lval);
  1090.  
  1091.     list = CDR(CDR(list));
  1092.   }
  1093.  
  1094.   return(unbound);
  1095. }
  1096.  
  1097.  
  1098. extern LispObject canonical_slot_initargs(LispObject*);
  1099.  
  1100. /* Sets up the canonical form and verifies */
  1101.  
  1102. EUFUN_3( canonical_slot_initargs, mod, env, slotspec)
  1103. {
  1104.   return nil;
  1105. }
  1106. EUFUN_CLOSE
  1107.  
  1108. /*
  1109.  
  1110.  * Various class / slot utilities...
  1111.  
  1112.  */
  1113.  
  1114. EUFUN_1( Fn_local_slots, class)
  1115. {
  1116.   LispObject i_d;
  1117.  
  1118.   i_d = class->CLASS.slot_table; 
  1119.  
  1120.   if (i_d == nil) return(nil); /* No slots at all */
  1121.  
  1122.   if (is_table(i_d)) {
  1123.     LispObject local = nil,all;
  1124.  
  1125.     EUCALLSET_1(all, Fn_table_parameters,i_d);
  1126.     while (all!=nil) {
  1127.       STACK_TMP(CDR(all));
  1128.       if (EUCALL_2(Fn_subclassp,classof(CAR(all)),Local_Slot_Description) != nil) {
  1129.     local = MYCONS(CAR(all),local);
  1130.       }
  1131.       UNSTACK_TMP(all);
  1132.     }
  1133.  
  1134.     return(local);
  1135.   }
  1136.  
  1137.   CallError(stacktop,"as yet unimplemented instance_description type",class,
  1138.         NONCONTINUABLE);
  1139.  
  1140.   return(nil);  /* Dummy */
  1141. }
  1142. EUFUN_CLOSE
  1143.  
  1144. EUFUN_2( Fn_mutable_slot_p, object, slot )
  1145. {
  1146.   STUB("mutable-slot-p");
  1147.  
  1148.   return(lisptrue);
  1149. }
  1150. EUFUN_CLOSE
  1151.  
  1152. EUFUN_2( Fn_slot_exists_p, object, slotname )
  1153. {
  1154.   LispObject class = classof(object);
  1155.  
  1156.   /* May have to genericise it later */
  1157.  
  1158.   if ( TREF(CLASS_DESCS(class),slotname) != nil ) {
  1159.     return(slotname);
  1160.   }
  1161.   else {
  1162.     return(nil);
  1163.   }
  1164. }
  1165. EUFUN_CLOSE
  1166.  
  1167. EUFUN_2( Fn_slot_bound_p, object, slotname)
  1168. {
  1169.   
  1170.   if (EUCALL_2(Fn_slot_exists_p,object,slotname) == nil) {
  1171.     signal_message(stacktop,SLOT_MISSING,"slot-bound-p",slotname);
  1172. /*    CallError(stacktop,"slot-missing",slotname,NONCONTINUABLE); */
  1173.   }
  1174.  
  1175.   if (EUCALL_2(Fn_slot_value,object,slotname) == unbound) {
  1176.     return(nil);
  1177.   }
  1178.   else {
  1179.     return(slotname);
  1180.   }
  1181. }
  1182. EUFUN_CLOSE
  1183.  
  1184. EUFUN_1( Fn_slot_description_readers, desc)
  1185. {
  1186.   STUB("slot-description-readers");
  1187.  
  1188.   return(nil);
  1189. }
  1190. EUFUN_CLOSE
  1191.  
  1192. EUFUN_1( Fn_slot_description_writers, desc)
  1193. {
  1194.   STUB("slot-description-writers");
  1195.  
  1196.   return(nil);
  1197. }
  1198. EUFUN_CLOSE
  1199.  
  1200. /*
  1201.  
  1202.  * Constructor / accessor generation.
  1203.  *
  1204.  * These are set out in the C equivalent of...
  1205.  *
  1206.  * (defun make-reader (class slot-name)
  1207.  *   (let ((pos (slot-description-position 
  1208.  *                (find-slot-description class slot-name))))
  1209.  *     (lambda (obj) (slot-value-using-class class obj pos))))
  1210.  *
  1211.  * ... or some such. All accessors have their home in the same module.
  1212.  *               (That module being 'classes' for now)
  1213.  *
  1214.  *   make-constructor killed --- done at lisp-level now.
  1215.  */
  1216.  
  1217.  
  1218. /* Template for structure-class metainstances... */
  1219.  
  1220. EUFUN_2( structure_reader_template, env, obj)
  1221. {
  1222.   if (EUCALL_2(Fn_subclassp,classof(obj),
  1223.            symbol_ref(stacktop,NULL,env,sym_class)) == nil)
  1224.     CallError(stacktop,"wrong class of object for reader",obj,NONCONTINUABLE);
  1225.  
  1226.   return(slotref(obj,intval(symbol_ref(stacktop,NULL,env,sym_position))));
  1227. }
  1228. EUFUN_CLOSE
  1229.  
  1230. /* Anything template */
  1231.  
  1232. EUFUN_2( reader_template, env, obj)
  1233. {    
  1234.   RETURN_EUCALL(EUCALL_2(Fn_slot_value,obj,((Env)env)->value));
  1235. }
  1236. EUFUN_CLOSE
  1237.  
  1238. EUFUN_2( Fn_make_reader, class, slot)
  1239. {
  1240.   LispObject desc,pos;
  1241.  
  1242.   if (!is_class(class))
  1243.     CallError(stacktop,"make-reader: non class",class,NONCONTINUABLE);
  1244.  
  1245.   if (classof(class) == Structure_Class) {
  1246.  
  1247.     EUCALLSET_2(desc, Fn_find_slot_description,class,slot);
  1248.     EUCALLSET_1(pos, Fn_slot_description_position,desc);
  1249.  
  1250.     if (pos == unbound)
  1251.       CallError(stacktop,"make-reader: cannot-make-reader",pos,NONCONTINUABLE);
  1252.  
  1253.     return(make_anonymous_module_env_function_2(stacktop,
  1254.                         (LispObject) classes_module,
  1255.                         structure_reader_template,
  1256.                         1,
  1257.                         sym_position,pos,
  1258.                         sym_class,class));
  1259.   }
  1260.  
  1261.   /* Most general - hacking slot-value */
  1262.  
  1263.   return(make_anonymous_module_env_function_1(stacktop,
  1264.                           (LispObject) classes_module,
  1265.                           reader_template,1,
  1266.                           sym_nil,slot));
  1267. }
  1268. EUFUN_CLOSE
  1269.  
  1270. EUFUN_3( structure_writer_template, env, obj, val)
  1271. {
  1272.   LispObject tmp;
  1273.  
  1274.   if (EUCALL_2(Fn_subclassp,classof(obj),
  1275.            symbol_ref(stacktop,NULL,env,sym_class)) == nil)
  1276.     CallError(stacktop,"wrong class of object for writer",obj,
  1277.           NONCONTINUABLE);
  1278.   
  1279.   slotrefupdate(obj,intval(symbol_ref(stacktop,NULL,env,sym_position)),val);
  1280.   
  1281.   return val;
  1282. }
  1283. EUFUN_CLOSE
  1284.  
  1285. EUFUN_3( writer_template, env, obj, val)
  1286. {
  1287.   RETURN_EUCALL(EUCALL_3(Fn_slot_value_setter,obj,((Env)env)->value,val));
  1288. }
  1289. EUFUN_CLOSE
  1290.  
  1291. EUFUN_2( Fn_make_writer, class, slot)
  1292. {
  1293.   LispObject desc, pos;
  1294.  
  1295.   if (!is_class(class))
  1296.     CallError(stacktop,"make-writer: non class",class,NONCONTINUABLE);
  1297.  
  1298.   if (classof(class) == Structure_Class) {
  1299.  
  1300.     EUCALLSET_2(desc, Fn_find_slot_description,class,slot);
  1301.     EUCALLSET_1(pos, Fn_slot_description_position,desc);
  1302.  
  1303.     if (pos == unbound)
  1304.       CallError(stacktop,"make-writer: cannot-make-writer",pos,NONCONTINUABLE);
  1305.  
  1306.     return(make_anonymous_module_env_function_2(stacktop,(LispObject) classes_module,
  1307.                         structure_writer_template,
  1308.                         2,
  1309.                         sym_position,pos,
  1310.                         sym_class,class));
  1311.   }
  1312.  
  1313.   return(make_anonymous_module_env_function_1(stacktop,
  1314.                           (LispObject) classes_module,
  1315.                           writer_template,2,
  1316.                           sym_nil,slot));
  1317. }
  1318. EUFUN_CLOSE
  1319.  
  1320. /* 
  1321.  * Chris Burdorf hacks...
  1322.  */
  1323.  
  1324. #define is_instance(obj) (typeof(obj) == TYPE_INSTANCE)
  1325.  
  1326. EUFUN_1( Fn_instance_slots, inst)
  1327. {
  1328.   if (!is_instance(inst))
  1329.     CallError(stacktop,
  1330.           "instance-slots: not a simple instance",inst,NONCONTINUABLE);
  1331. #ifdef naff /* Mon Jul 22 19:05:48 1991 */
  1332. /**/
  1333. /**/  return(inst->INSTANCE.slots);
  1334. #endif /* naff Mon Jul 22 19:05:48 1991 */
  1335.   printf("Instance slots: unimplementable function\n");
  1336.   return nil;
  1337. }
  1338. EUFUN_CLOSE
  1339.  
  1340. EUFUN_2( Fn_instance_slots_setter, inst, val)
  1341. {
  1342.   if (!is_instance(inst))
  1343.     CallError(stacktop,
  1344.           "instance-slots: not a simple instance",inst,NONCONTINUABLE);
  1345.  
  1346.   printf("Instance slots setter: unimplementable function\n");
  1347.   return nil;
  1348. #ifdef naff /* Mon Jul 22 19:06:24 1991 */
  1349. /**/  inst->INSTANCE.slots = val;
  1350. /**/  return(inst);
  1351. #endif /* naff Mon Jul 22 19:06:24 1991 */
  1352. }
  1353. EUFUN_CLOSE
  1354.  
  1355. EUFUN_2(Fn_set_class,class,meta)
  1356. {    
  1357.   lval_classof(class)=meta;
  1358.   
  1359.   return nil;
  1360. }
  1361. EUFUN_CLOSE
  1362.  
  1363. EUFUN_1(Fn_allocate_class,meta)
  1364. {
  1365.   LispObject ans;
  1366.   
  1367.   if (meta==nil)
  1368.     {
  1369.       ans=allocate_class(stacktop,NULL);
  1370.       lval_classof(ans)=meta;
  1371.     }
  1372.   else
  1373.     ans=allocate_class(stacktop,meta);
  1374.  
  1375.   return ans;
  1376. }
  1377. EUFUN_CLOSE
  1378.  
  1379. /* This can only be called *before* the class allocates anything! */
  1380. EUFUN_2(Fn_set_class_size, class, n)
  1381. {
  1382.   class->CLASS.local_count=intval(n);
  1383.  
  1384.   return n;
  1385. }
  1386. EUFUN_CLOSE
  1387.  
  1388. EUFUN_1(Fn_allocate_object,class)
  1389. {
  1390.   LispObject ans;
  1391.  
  1392.   ans=allocate_instance(stacktop,class);
  1393.   
  1394.   return ans;
  1395. }
  1396. EUFUN_CLOSE
  1397.  
  1398. EUFUN_2(Fn_set_type,x,n)
  1399. {
  1400.   lval_typeof(x)=intval(n);
  1401.   return x;
  1402. }
  1403. EUFUN_CLOSE
  1404.  
  1405. /* *************************************************************** */
  1406. /* Initialisation of this module (should be seperate...)           */
  1407. /* *************************************************************** */
  1408.  
  1409. /* Class name module stuff... */
  1410.  
  1411. #define CLASS_NAMES_ENTRIES 111 /* Too many */
  1412. MODULE Module_class_names;
  1413. LispObject Module_class_names_values[CLASS_NAMES_ENTRIES];
  1414.  
  1415. void register_class_names(LispObject *stacktop,LispObject c)
  1416. {
  1417.   LispObject sub;
  1418.  
  1419.   make_module_entry_using_symbol(stacktop,c->CLASS.name,c);
  1420.  
  1421.   sub = c->CLASS.subclasses;
  1422.  
  1423.   while (sub != nil) {
  1424.     STACK_TMP(CDR(sub));
  1425.     register_class_names(stacktop,CAR(sub));
  1426.     UNSTACK_TMP(sub);
  1427.   }
  1428. }
  1429.  
  1430. /* *************************************************************** */
  1431. /* Initialisation of this module                                   */
  1432. /* *************************************************************** */
  1433.  
  1434. #define SET_ASSOC(a,b) \
  1435.   { LispObject tmp,tmp2; \
  1436.     STACK_TMP(a); \
  1437.     tmp2=b; \
  1438.     UNSTACK_TMP(tmp); \
  1439.     set_anon_associate(stacktop,tmp,tmp2); \
  1440.   }
  1441.  
  1442. void initialise_classes(LispObject *stacktop)
  1443. {
  1444.   extern void set_anon_associate(LispObject*,LispObject,LispObject);
  1445.   /* Internal symbols... */
  1446.  
  1447.   sym_direct_superclasses     =get_symbol(stacktop,"direct-superclasses");
  1448.   add_root(&sym_direct_superclasses);
  1449.   sym_direct_slot_descriptions=get_symbol(stacktop,"direct-slot-descriptions");
  1450.   add_root(&sym_direct_slot_descriptions);
  1451.   sym_metaclass_hypotheses    = get_symbol(stacktop,"metaclass-hypotheses");
  1452.   add_root(&sym_metaclass_hypotheses);
  1453.   sym_slot_class = get_symbol(stacktop,"slot-class");
  1454.   add_root(&sym_slot_class);
  1455.   sym_slot_initargs = get_symbol(stacktop,"slot-initargs");
  1456.   add_root(&sym_slot_initargs);
  1457.   sym_predicate = get_symbol(stacktop,"predicate");
  1458.   add_root(&sym_predicate);
  1459.   /* The class names module */
  1460.  
  1461. /**#ifdef OLDSYS**/
  1462.   open_module(stacktop,
  1463.           &Module_class_names,Module_class_names_values,
  1464.           "class-names",CLASS_NAMES_ENTRIES);
  1465.   register_class_names(stacktop,Object);
  1466.   close_module();
  1467. /**#endif**/
  1468.   /* Class operations */
  1469.  
  1470.   open_module(stacktop,
  1471.           &Module_classes,Module_classes_values,
  1472.           "classes",CLASSES_ENTRIES);
  1473.  
  1474.   /* Class object accessors... */
  1475.  
  1476.   (void) make_module_function(stacktop,"classp",Fn_classp,1);
  1477.   (void) make_module_function(stacktop,"subclassp",Fn_subclassp,2);
  1478.   (void) make_module_function(stacktop,"class-of",Fn_class_of,1);
  1479.   (void) make_module_function(stacktop,"class-name",Fn_class_name,1);
  1480.   (void) make_module_function(stacktop,"class-prototype",Fn_class_prototype,1);
  1481.   (void) make_module_function(stacktop,"class-precedence-list",
  1482.                   Fn_class_precedence_list,1);
  1483.   (void) make_module_function(stacktop,"class-direct-superclasses",
  1484.                   Fn_class_direct_superclasses,1);
  1485.   (void) make_module_function(stacktop,"class-direct-subclasses",
  1486.                   Fn_class_direct_subclasses,1);
  1487.   (void) make_module_function(stacktop,"class-slot-descriptions",
  1488.                   Fn_class_slot_descriptions,1);
  1489.   (void) make_module_function(stacktop,"class-direct-slot-descriptions",
  1490.                   Fn_class_direct_slot_descriptions,1);
  1491.  
  1492.   /* Inheritance... */
  1493.   generic_compute_class_precedence_list
  1494.     = make_wrapped_module_generic(stacktop,"compute-class-precedence-list",1,
  1495.                   Gf_compute_class_precedence_list);
  1496.   add_root(&generic_compute_class_precedence_list);
  1497.   (void) make_module_function(stacktop,"generic_compute_class_precedence_list,Standard_Class",
  1498.                   Md_compute_class_precedence_list_Class,
  1499.                   1);
  1500.   
  1501.   /* Slot access protocol... */
  1502.  
  1503.   generic_slot_value_using_class 
  1504.     = make_module_generic(stacktop,"slot-value-using-class",3);
  1505.   add_root(&generic_slot_value_using_class);
  1506.   make_module_function(stacktop,"generic_slot_value_using_class,Structure_Class",
  1507.                Md_slot_value_using_class_Structure_Class,
  1508.                3);
  1509.   make_module_function(stacktop,"generic_slot_value_using_class,Standard_Class",
  1510.                Md_slot_value_using_class_Standard_Class,
  1511.                3);
  1512.  
  1513.   generic_slot_value_using_class_setter 
  1514.     = make_module_generic(stacktop,"(setter slot-value-using-class)",4);
  1515.   add_root(&generic_slot_value_using_class_setter);
  1516.   make_module_function(stacktop,"generic_slot_value_using_class_setter,StructureClass",
  1517.                Md_slot_value_using_class_setter_Structure_Class,
  1518.                4);
  1519.   make_module_function(stacktop,"generic_slot_value_using_class_setter,Standard_Class",
  1520.                Md_slot_value_using_class_setter_Standard_Class,
  1521.                4);
  1522.   SET_ASSOC(generic_slot_value_using_class,
  1523.         generic_slot_value_using_class_setter);
  1524.  
  1525.   generic_slot_value_using_slot_description 
  1526.     = make_module_generic(stacktop,"slot-value-using-slot-description",2);
  1527.   add_root(&generic_slot_value_using_slot_description);
  1528.   make_module_function(stacktop,"generic_slot_value_using_slot_description,Object,Local_Slot_Description",
  1529.                Md_slot_value_using_slot_description_Local_Slot_Description,
  1530.                2);
  1531.  
  1532.   generic_slot_value_using_slot_description_setter 
  1533.     = make_module_generic(stacktop,
  1534.               "(setter slot-value-using-slot-description)",3);
  1535.   add_root(&generic_slot_value_using_slot_description_setter);
  1536.   make_module_function(stacktop,
  1537.                "generic_slot_value_using_slot_description_setter,Object,Local_Slot_Description",
  1538.                Md_slot_value_using_slot_description_setter_Local_Slot_Description,
  1539.                3);
  1540.   SET_ASSOC(generic_slot_value_using_slot_description,
  1541.         generic_slot_value_using_slot_description_setter);
  1542.       
  1543.   generic_find_slot_description 
  1544.     = make_module_generic(stacktop,"find-slot-description",2);
  1545.   add_root(&generic_find_slot_description);
  1546.   make_module_function(stacktop,"generic_find_slot_description,Structure_Class",
  1547.         Md_find_slot_description_Structure_Class,
  1548.         2);
  1549.   make_module_function(stacktop,"generic_find_slot_description,Standard_Class",
  1550.         Md_find_slot_description_Standard_Class,
  1551.         2);
  1552.  
  1553.   
  1554.   SET_ASSOC(make_module_function(stacktop,"slot-value",
  1555.                  Fn_slot_value,2),
  1556.         make_module_function(stacktop,"slot-value-setter",
  1557.                  Fn_slot_value_setter,3));
  1558.  
  1559.   /* Inheritance... */
  1560.  
  1561.   (void) make_module_function(stacktop,"add-superclasses",Fn_add_superclasses,3);
  1562.   (void) make_module_function(stacktop,"add-subclass",Fn_add_subclass,2);
  1563.   (void) make_module_function(stacktop,"collect-slots",Fn_collect_slots,2);
  1564.   
  1565.   generic_make_slot_description 
  1566.     = make_module_generic(stacktop,"make-slot-description",2);
  1567.   add_root(&generic_make_slot_description);
  1568.   (void) make_module_function(stacktop,"generic_make_slot_description,Standard_Class",
  1569.                   Md_make_slot_description_Class,2);
  1570.  
  1571.   generic_make_inherited_slot_description 
  1572.     = make_module_generic(stacktop,"make-inherited-slot-description",3);
  1573.   add_root(&generic_make_inherited_slot_description);
  1574.   (void) make_module_function(stacktop,
  1575.                   "generic_make_inherited_slot_description,Standard_Class,Slot_Description",
  1576.                   Md_make_inherited_slot_description_Class_Slot_Description,3
  1577.                   );
  1578.  
  1579.   generic_add_slot_description = make_module_generic(stacktop,
  1580.                              "add-slot-description",2);
  1581.   add_root(&generic_add_slot_description);
  1582.   (void) make_module_function(stacktop,"generic_add_slot_description,StandardClass,SlotDescription",
  1583.                   Md_add_slot_description_Class_Slot_Description,2
  1584.                   );
  1585.   (void) 
  1586.     make_module_function(stacktop,"generic_add_slot_description,StandardClass,LocalSlotDescription",
  1587.              Md_add_slot_description_Class_Local_Slot_Description,2
  1588.              );
  1589.  
  1590.   /* GF initialisation */
  1591.  
  1592.   generic_allocate_instance = make_module_generic(stacktop,
  1593.                           "allocate-instance",2);
  1594.   add_root(&generic_allocate_instance);
  1595.   make_module_function(stacktop,"generic_allocate_instance,StandardClass",
  1596.                Md_allocate_instance_1,2);
  1597.   make_module_function(stacktop,"generic_allocate_instance,StructureClass",
  1598.                Md_allocate_instance_2,2);
  1599.   make_module_function(stacktop,"generic_allocate_instance,Slot_Description_Class",
  1600.                Md_allocate_instance_3,2);
  1601.   make_module_function(stacktop,"generic_allocate_instance,Condition_Class",
  1602.                Md_allocate_instance_4,2);
  1603.   make_module_function(stacktop,"generic_allocate_instance,Primitive_Class",
  1604.                Md_allocate_instance_Primitive_Class,
  1605.                2);
  1606.  
  1607.   generic_initialize_instance = make_module_generic(stacktop,
  1608.                             "initialize-instance",2);
  1609.   add_root(&generic_initialize_instance);
  1610.   make_module_function(stacktop,"generic_initialize_instance,Object",
  1611.                Md_initialize_instance_1,2);
  1612.   make_module_function(stacktop,"generic_initialize_instance,Standard_Class",
  1613.                Md_initialize_instance_2,2);
  1614.   make_module_function(stacktop,"generic_initialize_instance,Slot_Description",
  1615.                Md_initialize_instance_3,2);
  1616.   make_module_function(stacktop,"generic_initialize_instance,Default_Condition",
  1617.                Md_initialize_instance_4,2); 
  1618.  
  1619.   make_module_function(stacktop,"make-instance",Gf_make_instance,-2);
  1620.  
  1621.   make_module_function(stacktop,"make-reader",Fn_make_reader,2);
  1622.   make_module_function(stacktop,"make-writer",Fn_make_writer,2);
  1623.  
  1624.   SET_ASSOC(make_module_function(stacktop,"slots-of",
  1625.                  Fn_instance_slots,
  1626.                  1),
  1627.         make_unexported_module_function(stacktop,"instance-slots-setter",
  1628.                         Fn_instance_slots_setter,
  1629.                         2));
  1630.   make_module_function(stacktop,"set-class-size",Fn_set_class_size,2);
  1631.   make_module_function(stacktop,"set-class-of",Fn_set_class,2);
  1632.   make_module_function(stacktop,"set-type",Fn_set_type,2);
  1633.   make_module_function(stacktop,"allocate-class",Fn_allocate_class,1);
  1634.   make_module_function(stacktop,"allocate-object",Fn_allocate_object,1);
  1635.   initialise_slots(stacktop);
  1636.  
  1637.   close_module();
  1638.   
  1639.   {
  1640.     LispObject xx;
  1641.     xx=get_symbol(stacktop,"classes");
  1642.     
  1643.     classes_module=get_module(stacktop,xx);
  1644.     add_root(&classes_module);
  1645.   }
  1646. }
  1647.  
  1648.